functor BlockUnion (S : BLOCKUNION_STRUCTS) : BLOCKUNION =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
  
  fun cookBlock (f, b) =
      let fun doit bb =
              case bb
               of K.T {name,
                       prop,
                       stms,
                       transfer,
                       successors} =>
                  (case transfer
                    of J.If {line, value, truee, falsee} =>
                       let val rt = F.isEmptyBlock (f, truee)
                           val rf = F.isEmptyBlock (f, falsee)
                           val (newTruee, newFalsee) =
                               case (rt, rf)
                                of (SOME rt', SOME rf') =>
                                   (debugPrint "to (some, some)\n"
                                   ; debugPrint (Id.toString rt')
                                   ; debugPrint (Id.toString rf')
                                   ; (rt', rf'))
                                 | (SOME rt', NONE) => (truee, falsee)
                                 | (NONE, SOME rf') => (truee, falsee)
                                 | (NONE, NONE) => (truee, falsee)
                       in  if Id.equals (newTruee, newFalsee)
                           then K.T {name = name,
                                     prop = prop,
                                     stms = stms,
                                     transfer =  J.Jump {line = line,
                                                         label = truee},
                                     successors = [truee]}
                           else bb
                       end
                     | _ => bb)
      in  doit b
      end
      
  fun loop (f, blocks) =
      case blocks
       of [] => []
        | x :: xs => 
          let val newBlock = cookBlock (f, x)
          in  newBlock :: (loop (f, xs))
          end
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val newBlocks = loop (f, blocks)
              val new = F.T {name = name,
                             exit = exit,
                             rettype = rettype,
                             args = args,
                             locals = locals,
                             blocks = newBlocks,
                             pre = pre,
                             post = post}
              val _ = debugPrint "\noutput the graph after block union\n"
              val _ = if tag
                      then F.toDot (new, "afterBlockUnion")
                      else ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\nblock union starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\nblock union finished\n"
      in  new
      end
end
